perm filename CHS1.F4[1,VDS]1 blob sn#098022 filedate 1974-04-17 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	      SUBROUTINE DIGIT
C00006 00003	      SUBROUTINE DECPT
C00008 ENDMK
CāŠ—;
      SUBROUTINE DIGIT
C         DATE OF LAST CHANGE - 740317
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP, FIXFLG
          DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
     *              R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (.NOT.EEX) GO TO 1
             D(15)=D(16)
             D(16)=CODE
             RETURN
    1     IF (L.GT.13) GO TO 2
             IF (M.LE.13) GO TO 3
    2           IF (.NOT.DP) CALL EXPON (D(14),D(15),D(16),1)
                RETURN
    3     IF (.NOT.FIXFLG) GO TO 4
          IF (.NOT.DP) GO TO 10
    4        M=M+1
             D(M)=CODE
    5        IF (DP) GO TO 6
             IF (L.EQ.1) GO TO 7
                CALL EXPON (X(1,15),X(1,16),X(1,17),1)
                GO TO 8
    6        IF (L.NE.1) GO TO 8
                CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
    7        IF (CODE.EQ.0) RETURN
    8           L=L+1
                X(1,L)=CODE
    9           RETURN
   10     IF (M.NE.1) GO TO 12
             D(2)=10
             D(3)=11
             DO 11 I=1,FIX
   11           D(I+3)=10
             D(FIX+3)=CODE
             M=1
             W(1)=2
             IF (CODE.EQ.0) RETURN
             L=2
             X(1,2)=CODE
             X(1,15)=13
             X(1,17)=FIX
             RETURN
   12     M=M+1
          IF (M.LE.FIX+1) GO TO 14
             IF (M.LE.FIX+2) GO TO 13
                D(2)=D(4)
                COUNT=FIX
                GO TO 15
   13        J=W(1)
             D(J)=D(J+1)
             W(1)=W(1)+1
             D(M)=CODE
             GO TO 5
   14     COUNT=FIX-1
   15     K=4
   16     D(K)=D(K+1)
          K=K+1
          COUNT=COUNT-1
          IF (COUNT.NE.0) GO TO 16
             D(FIX+3)=CODE
             GO TO 5
          END
      SUBROUTINE DECPT
C         DATE OF LAST CHANGE - 740404
          IMPLICIT INTEGER (A-Z)
          LOGICAL EEX, DP, FIXFLG
          DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
          COMMON /STACK/ P, X, OP, D
     *           /FLAGS/ EEX, DP, START, JUMP, NEXT, JMP, FIXFLG
     *           /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
          IF (EEX) GO TO 5
          IF (.NOT.DP) GO TO 1
             OP(1)=50
             CALL ENTRUP (&4)
             GO TO 3
    1     DP=.TRUE.
          IF (.NOT.FIXFLG) GO TO 3
             COUNT=FIX
    2        J=W(1)
             D(J)=D(J+1)
             W(1)=W(1)+1
             COUNT=COUNT-1
             IF (COUNT.NE.0) GO TO 2
             CALL EXPON (X(1,15),X(1,16),X(1,17),FIX)
    3     M=M+1
          D(M)=11
    4     RETURN
    5     EEX=.FALSE.
          RETURN
          END